home *** CD-ROM | disk | FTP | other *** search
- ;
- ; 16.defining
- ;
- ;
-
-
- * ,view (s -- ) View fields are not used, can be used to count
- ; word useage.
- dc.w -1
- dc.l link0
- link0 set *-4
- dc.b $85,$2c,'vie',$80!'w'
- cnop 0,2
- _comma_view dc.l nest
- dc.l _0,_w_comma,_exit
-
-
-
- * "create (s str -- ) Creates a header using the string str.
- ; Makes a view field (1 word), next sets a 0 link field, stores name address
- ; into 'last', issues a duplicate message, if warning and duplicate.
- ; Links into the proper list (hash), sets high bits on first and last char
- ; of the name. Sets code field to docreate, same as a variable.
- dc.w -1
- dc.l link2
- link2 set *-4
- dc.b $87,'"creat',$80!'e'
- cnop 0,2
- _quote_create dc.l nest
- dc.l _count,_here,_even
- dc.l _2_plus,_4_plus,_place
- dc.l _align,_comma_view,_here,_0,_comma
- dc.l _here,_last,_store,_here
- dc.l _warning,_fetch,_question_branch,2$
- dc.l _find,_question_branch,1$
- dc.l _here,_count,_type,_nest_dot_quote
- dc.b 15,' isn',$27,'t unique ',0
- cnop 0,2
- 1$ dc.l _drop,_here
- 2$ dc.l _current,_fetch,_hash,_dup,_fetch
- dc.l _here,_4_minus,_rot,_store,_swap,_store
- dc.l _here,_dup,_c_fetch,_width,_fetch,_min
- dc.l _2dup,_plus,_minus_rot
- dc.l _1_plus,_allot,_align
- dc.l _nest_lit,128,_swap,_cset
- dc.l _nest_lit,128,_swap,_cset
- dc.l _compile,docreate,_exit
-
- * create (s -- ) <word>
- ; Creates a header with the name <word>
- dc.w -1
- dc.l link3
- link3 set *-4
- dc.b $86,'creat',$80!'e'
- cnop 0,2
- _create dc.l nest
- dc.l _bl,_word,_question_uppercase
- dc.l _quote_create,_exit
-
- * !csp (s -- ) save current stack level for checking.
- dc.w -1
- dc.l link1
- link1 set *-4
- dc.b $84,'!cs',$80!'p'
- cnop 0,2
- _store_csp dc.l nest
- dc.l _sp_fetch,_csp,_store,_exit
-
- * ?csp (s -- ) Issue error message if stack has changed.
- dc.w -1
- dc.l link3
- link3 set *-4
- dc.b $84,'?cs',$80!'p'
- cnop 0,2
- _question_csp dc.l nest
- dc.l _sp_fetch,_csp,_fetch,_not_equals
- dc.l _nest_abort_quote
- dc.b 14,'Stack Changed',0
- cnop 0,2
- dc.l _exit
-
- * hide (s -- ) Remove last header from the linked list.
- dc.w -1
- dc.l link0
- link0 set *-4
- dc.b $84,'hid',$80!'e'
- cnop 0,2
- _hide dc.l nest
- dc.l _last,_fetch,_dup,_n_to_link,_fetch
- dc.l _swap,_current,_fetch,_hash,_store
- dc.l _exit
-
- * reveal (s -- ) Replace the last definition into the linked list.
- dc.w -1
- dc.l link2
- link2 set *-4
- dc.b $86,'revea',$80!'l'
- cnop 0,2
- _reveal dc.l nest
- dc.l _last,_fetch,_dup,_n_to_link
- dc.l _swap,_current,_fetch,_hash,_store
- dc.l _exit
-
- * (;uses) (s -- ) Sets the code field of the last definition to
- ; the cell following.
- dc.w -1
- dc.l link0
- link0 set *-4
- dc.b $87,'(;uses',$80!')'
- cnop 0,2
- _nest_semi_colon_uses
- dc.l nest
- dc.l _r_from,_fetch,_last,_fetch
- dc.l _name_from,_store,_exit
-
- * assembler (s -- ) Vocabulary assembler. No words are defined here
- ; when loading the assembler, all the words are defined.
- dc.w -1
- dc.l link1
- link1 set *-4
- dc.b $89,'assemble',$80!'r'
- cnop 0,2
- _assembler dc.l vocabulary_does
- dc.l 0
- dc.l 0
- dc.l 0
- dc.l 0
- dc.l voc_link
- voc_link set *-4
-
- * ;uses (s -- ) Sets the code field of the last word to the
- ; following cell.
- dc.w -1
- dc.l link3
- link3 set *-4
- dc.b $85!immediate,';use',$80!'s'
- cnop 0,2
- _semi_colon_uses dc.l nest
- dc.l _question_csp,_compile,_nest_semi_colon_uses
- dc.l _left_bracket,_reveal,_assembler
- dc.l _exit
-
- * (;code) (s -- ) Sets the code field of the last word to the
- ; address following.
- dc.w -1
- dc.l link0
- link0 set *-4
- dc.b $87,'(;code',$80!')'
- cnop 0,2
- _nest_semi_colon_code
- dc.l nest
- dc.l _r_from,_last,_fetch,_name_from
- dc.l _store,_exit
-
- * ;code (s -- ) Redefines the runtime portion of the last word
- ; to the code following.
- dc.w -1
- dc.l link3
- link3 set *-4
- dc.b $85!immediate,';cod',$80!'e'
- cnop 0,2
- _semi_colon_code dc.l nest
- dc.l _question_csp,_compile
- dc.l _nest_semi_colon_code
- dc.l _left_bracket,_reveal
- dc.l _assembler,_exit
-
- * does> (s -- ) Specifies the run time portion of a defining
- ; word in high level Forth. When run the address of the created word will
- ; be on the stack.
- dc.w -1
- dc.l link0
- link0 set *-4
- dc.b $85!immediate,'does',$80!'>'
- cnop 0,2
- _does_from dc.l nest
- dc.l _compile,_nest_semi_colon_code
- dc.l _nest_lit,$4EB9,_w_comma
- dc.l _nest_lit,dodoes,_comma
- dc.l _exit
-
- * [ (s -- ) Start interpreting, stop compiling.
- dc.w -1
- dc.l link3
- link3 set *-4
- dc.b $81!immediate,$80!'['
- cnop 0,2
- _left_bracket dc.l nest
- dc.l _state,_off,_exit
-
- * ] (s -- ) The compiling loop. Sets 'state', looks up the
- ; word in the input stream, executes it if it is immediate, otherwise
- ; compiles it. If the word is not found, converts it to a number single or
- ; double. Stops when the input is empty or the state has been altered.
- dc.w -1
- dc.l link1
- link1 set *-4
- dc.b $81,$80!']'
- cnop 0,2
- _right_bracket dc.l nest
- dc.l _state,_on
- 1$ dc.l _question_stack,_defined,_dup
- dc.l _question_branch,4$
- dc.l _0_greater,_question_branch,2$
- dc.l _execute,_branch,3$
- 2$ dc.l _comma
- 3$ dc.l _branch,6$
- 4$ dc.l _drop,_number,_double_question
- dc.l _question_branch,5$
- dc.l _dliteral,_branch,6$
- 5$ dc.l _drop,_literal
- 6$ dc.l _true,_done_question,_question_branch,1$
- dc.l _exit
-
- * : (s -- ) Starts a colon definition. The word is hidden
- ; until it is defined, or if recursion is required.
- dc.w -1
- dc.l link2
- link2 set *-4
- dc.b $81,$80!':'
- cnop 0,2
- _colon dc.l nest
- dc.l _store_csp,_current,_fetch
- dc.l _context,_store,_create,_hide
- dc.l _right_bracket,_nest_semi_colon_uses
- dc.l nest
-
- * ; (s -- ) Ends a colon definition. Stops compiling.
- dc.w 0
- dc.l link3
- link3 set *-4
- dc.b $81!immediate,$80!';'
- cnop 0,2
- _semi_colon dc.l nest
- dc.l _question_csp,_compile,_unnest
- dc.l _reveal,_left_bracket
- dc.l _exit
-
- * recursive (s -- ) Be very carefull, stack can be too small.
- dc.w -1
- dc.l link2
- link2 set *-4
- dc.b $89!immediate,'recursiv',$80!'e'
- cnop 0,2
- _recursive dc.l nest
- dc.l _reveal,_exit
-
- * constant (s n -- ) Defines a constant.
- ; (s -- n ) Runtime returns a number.
- dc.w -1
- dc.l link3
- link3 set *-4
- dc.b $88,'constan',$80!'t'
- cnop 0,2
- _constant dc.l nest
- dc.l _create,_comma,_nest_semi_colon_uses
- dc.l doconstant
-
- * variable (s -- ) Defining word for variables.
- ; (s -- addr ) Runtime returns the address of the var.
- dc.w -1
- dc.l link2
- link2 set *-4
- dc.b $88,'variabl',$80!'e'
- cnop 0,2
- _variable dc.l nest
- dc.l _create,_0,_comma,_nest_semi_colon_uses
- dc.l docreate
-
- * defer (s -- ) Defines an execution vector, defaults to crash.
- ; Vectors are changed using 'is'
- dc.w -1
- dc.l link0
- link0 set *-4
- dc.b $85,'defe',$80!'r'
- cnop 0,2
- _defer dc.l nest
- dc.l _create,_nest_lit,_crash
- dc.l _comma,_nest_semi_colon_uses
- dc.l dodefer
-
- * vocabulary (s -- ) Defining word for vocabularies.
- ; At runtime context is changed to point to the vocabulary.
- ; voc-link is used to forget defined vocabularies in order.
- dc.w -1
- dc.l link2
- link2 set *-4
- dc.b $8A,'vocabular',$80!'y'
- cnop 0,2
- _vocabulary dc.l nest
- dc.l _create,_number_threads,_0
- dc.l _nest_do,2$
- 1$ dc.l _0,_comma
- dc.l _nest_loop,1$
- 2$ dc.l _here,_voc_link,_fetch,_comma
- dc.l _voc_link,_store
- dc.l _nest_semi_colon_code
- vocabulary_does dc.w $4EB9
- dc.l dodoes
- dc.l _context,_store,_exit
-
- * librarybase A word, which provides storage for the librarybase and
- ; links itself into the linked list lib-link.
- dc.w -1
- dc.l link0
- link0 set *-4
- dc.b $8B,'librarybas',$80!'e'
- cnop 0,2
- _librarybase dc.l nest
- dc.l _create,_0,_comma,_here,_lib_link,_fetch,_comma
- dc.l _lib_link,_store,_exit
-
- * definitions (s -- ) Definitions will be placed in the same vocabulary
- ; as the top of context.
- dc.w -1
- dc.l link0
- link0 set *-4
- dc.b $8b,'definition',$80!'s'
- cnop 0,2
- _definitions dc.l nest
- dc.l _context,_fetch,_current,_store
- dc.l _exit
-
- * avoc (s -- addr ) A variable used when switching to assembler,
- ; to hold the present context. Set back by end-code, see assembler.
- dc.w -1
- dc.l link1
- link1 set *-4
- dc.b $84,'avo',$80!'c'
- cnop 0,2
- _avoc dc.l docreate,0
-
- * (is) (s cfa -- ) the runtime for is, sets the deferred word
- ; following to the address on the stack.
- dc.w -1
- dc.l link0
- link0 set *-4
- dc.b $84,'(is',$80!')'
- cnop 0,2
- _nest_is dc.l nest
- dc.l _r_fetch,_fetch,_to_body,_store,_r_from
- dc.l _4_plus,_to_r
- dc.l _exit
-
- * is (s cfa -- ) <word>
- ; Sets the deferred <word> to the address on the stack.
- ; Note that this system doesn't have a multitasking section as in other
- ; F83's. It is left up to the Amiga. Is is fairly simple, as compared to
- ; is in F83.
- dc.w -1
- dc.l link1
- link1 set *-4
- dc.b $82!immediate,'i',$80!'s'
- cnop 0,2
- _is dc.l nest
- dc.l _state,_fetch,_question_branch,1$
- dc.l _compile,_nest_is,_branch,2$
- 1$ dc.l _tick,_to_body,_store
- 2$ dc.l _exit
-
-
-
